home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / lib / baltree.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  4.7 KB  |  184 lines  |  [TEXT/MPS ]
  1. (* Weight-balanced binary trees.
  2.    These are binary trees such that one child of a node has at most N times
  3.    as many elements as the other child. We take N=3. *)
  4.  
  5. #open "int";;
  6. #open "eq";;
  7. #open "exc";;
  8.  
  9. (* Compute the size (number of nodes and leaves) of a tree. *)
  10.  
  11. let size = function
  12.     Empty -> 1
  13.   | Node(_, _, _, s) -> s;;
  14.  
  15. (* Creates a new node with left son l, value x and right son r.
  16.    l and r must be balanced and size l / size r must be between 1/N and N.
  17.    Inline expansion of size for better speed. *)
  18.  
  19. let new l x r =
  20.   let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
  21.   let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
  22.   Node(l, x, r, sl + sr + 1);;
  23.  
  24. (* Same as new, but performs rebalancing if necessary.
  25.    Assumes l and r balanced, and size l / size r "reasonable"
  26.    (between 1/N^2 and N^2 ???).
  27.    Inline expansion of new for better speed in the most frequent case
  28.    where no rebalancing is required. *)
  29.  
  30. let bal l x r =
  31.   let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in
  32.   let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in
  33.   if sl > 3 * sr then
  34.     let (Node(ll, lv, lr, _)) = l in
  35.     if size ll >= size lr then
  36.       new ll lv (new lr x r)
  37.     else
  38.       let (Node(lrl, lrv, lrr, _)) = lr in
  39.       new (new ll lv lrl) lrv (new lrr x r)
  40.   else if sr > 3 * sl then
  41.     let (Node(rl, rv, rr, _)) = r in
  42.     if size rr >= size rl then
  43.       new (new l x rl) rv rr
  44.     else
  45.       let (Node(rll, rlv, rlr, _)) = rl in
  46.       new (new l x rll) rlv (new rlr rv rr)
  47.   else
  48.     Node(l, x, r, sl + sr + 1);;
  49.  
  50. (* Same as bal, but rebalance regardless of the original ratio
  51.    size l / size r *)
  52.  
  53. let rec join l x r =
  54.   let (Node(l', x', r', _) as t') = bal l x r in
  55.   let sl = size l' and sr = size r' in
  56.   if sl > 3 * sr or sr > 3 * sl then join l' x' r' else t'
  57. ;;
  58.  
  59. (* Merge two trees l and r into one.
  60.    All elements of l must precede the elements of r.
  61.    Assumes size l / size r between 1/N and N. *)
  62.  
  63. let rec merge = fun
  64.     Empty t -> t
  65.   | t Empty -> t
  66.   | (Node(l1, v1, r1, h1)) (Node(l2, v2, r2, h2)) ->
  67.       bal l1 v1 (bal (merge r1 l2) v2 r2)
  68. ;;
  69.  
  70. (* Same as merge, but does not assume anything about l and r. *)
  71.  
  72. let rec concat = fun
  73.     Empty t -> t
  74.   | t Empty -> t
  75.   | (Node(l1, v1, r1, h1)) (Node(l2, v2, r2, h2)) ->
  76.       join l1 v1 (join (concat r1 l2) v2 r2)
  77. ;;
  78.  
  79. (* Insertion *)
  80.  
  81. let add searchpred x t =
  82.   let rec add = function
  83.     Empty ->
  84.       Node(Empty, x, Empty, 1)
  85.   | Node(l, v, r, _) as t ->
  86.       let c = searchpred v in
  87.       if c == 0 then t else
  88.       if c < 0 then bal (add l) v r else bal l v (add r)
  89.   in add t
  90. ;;
  91.  
  92. (* Membership *)
  93.  
  94. let contains searchpred t =
  95.   let rec contains = function
  96.     Empty -> false
  97.   | Node(l, v, r, _) ->
  98.       let c = searchpred v in
  99.       if c == 0 then true else
  100.       if c < 0 then contains l else contains r
  101.   in contains t
  102. ;;
  103.  
  104. (* Search *)
  105.  
  106. let find searchpred t =
  107.   let rec find = function
  108.     Empty ->
  109.       raise Not_found
  110.   | Node(l, v, r, _) ->
  111.       let c = searchpred v in
  112.       if c == 0 then v else
  113.       if c < 0 then find l else find r
  114.   in find t
  115. ;;
  116.  
  117. (* Deletion *)
  118.  
  119. let remove searchpred t =
  120.   let rec remove = function
  121.     Empty ->
  122.       Empty
  123.   | Node(l, v, r, _) ->
  124.       let c = searchpred v in
  125.       if c == 0 then merge l r else
  126.       if c < 0 then bal (remove l) v r else bal l v (remove r)
  127.   in remove t
  128. ;;
  129.  
  130. (* Modification *)
  131.  
  132. let modify searchpred modifier t =
  133.   let rec modify = function
  134.     Empty ->
  135.       begin match modifier Nothing with
  136.         Nothing -> Empty
  137.       | Something v -> Node(Empty, v, Empty, 1)
  138.       end
  139.   | Node(l, v, r, s) ->
  140.       let c = searchpred v in
  141.       if c == 0 then
  142.         begin match modifier(Something v) with
  143.           Nothing -> merge l r
  144.         | Something v' -> Node(l, v', r, s)
  145.         end
  146.       else if c < 0 then bal (modify l) v r else bal l v (modify r)
  147.   in modify t
  148. ;;
  149.  
  150. (* Splitting *)
  151.  
  152. let split searchpred =
  153.   let rec split = function
  154.     Empty ->
  155.       (Empty, Nothing, Empty)
  156.   | Node(l, v, r, _) ->
  157.       let c = searchpred v in
  158.       if c == 0 then (l, Something v, r)
  159.       else if c < 0 then
  160.         let (ll, vl, rl) = split l in (ll, vl, join rl v r)
  161.       else
  162.         let (lr, vr, rr) = split r in (join l v lr, vr, rr)
  163.   in split
  164. ;;
  165.  
  166. (* Comparison (by lexicographic ordering of the fringes of the two trees). *)
  167.  
  168. let compare cmp s1 s2 =
  169.   let rec compare_aux = fun
  170.     [] [] -> 0
  171.   | [] _  -> -1
  172.   | _  [] -> 1
  173.   | (Empty::t1) (Empty::t2) ->
  174.       compare_aux t1 t2
  175.   | (Node(Empty, v1, r1, _) :: t1) (Node(Empty, v2, r2, _) :: t2) ->
  176.       let c = cmp v1 v2 in
  177.       if c != 0 then c else compare_aux (r1::t1) (r2::t2)
  178.   | (Node(l1, v1, r1, _) :: t1) t2 ->
  179.       compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
  180.   | t1 (Node(l2, v2, r2, _) :: t2) ->
  181.       compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
  182.   in
  183.     compare_aux [s1] [s2];;
  184.